home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / font-menus.Lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  9.1 KB  |  243 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;font-menus.lisp
  4. ;;copyright © 1988-1991 Apple Computer, Inc.
  5. ;;
  6. ;;
  7. ;;  this file defines a set of hierarchical menus which can be used for
  8. ;;  setting the font of the current window.
  9. ;;
  10. ;;
  11.  
  12. (in-package :ccl)
  13.  
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15. ;;
  16. ;; Mod History
  17. ;;
  18. ;; 04/28/93 mwp Release
  19. ;; 10/19/92 bill enable-font-menus-p is a little more general
  20. ;; 08/05/92 bill use buffer-set-font-spec, not buffer-set-font-codes
  21. ;; 06/13/92 bill Engber's idea to change the insertion font if
  22. ;;               the whole window is selected.
  23. ;; ------------- 2.0
  24. ;; 03/10/92 bill Doug Currie's enable-font-menus
  25. ;; 02/28/92 gb   remove redundant when from menu-item-action
  26. ;; ------------- 2.0f3
  27. ;; 10/16/91 bill eliminate consing at menu-update time.
  28. ;; 09/19/91 bill replace slot-value with accessors
  29. ;; 09/08/91 wkf  Prevent unneccessary consing and speed up menu-item-update.
  30. ;; 06/25/91 bill The *font-menu* is updated at startup.
  31. ;; 06/13/91 bill WKF's fix for menu-item-update when no windows are open.
  32. ;; 04/03/91 bill Prevent error in menu-item-update when there are no windows
  33. ;;
  34.  
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36. ;;
  37. ;;  define a font-menu class and some methods.
  38. ;;
  39.  
  40. (defclass font-menu (menu)
  41.   ((selection-font :initform (cons 0 0) :accessor selection-font)))
  42.  
  43. (defgeneric enable-font-menus-p (view)
  44.   (:method ((v fred-mixin)) t)
  45.   (:method ((v basic-editable-text-dialog-item)) t)
  46.   (:method ((v t))
  47.            (or (method-exists-p 'set-view-font-codes v)
  48.                (method-exists-p 'set-view-font v))))
  49.  
  50. (defmethod menu-update ((self font-menu))
  51.   (let* ((w (front-window))
  52.          (key-handler (and w  (or (current-key-handler w) w)))
  53.          (selection-font (selection-font self))
  54.          (ff 0) (ms 0))
  55.     (if (enable-font-menus-p key-handler)
  56.       (progn
  57.         (menu-item-enable self)
  58.         (multiple-value-setq (ff ms) (view-font-codes key-handler)))
  59.       (menu-item-disable self))
  60.     (setf (car selection-font) ff (cdr selection-font) ms))
  61.   (call-next-method))
  62.  
  63.  
  64. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65. ;;
  66. ;;  define some variables for holding the menus
  67. ;;
  68.  
  69. (defvar *font-menu*       (make-instance 'font-menu :menu-title "Font")) ;  9-Aug-91 -wkf
  70. (defvar *font-size-menu*  (make-instance 'font-menu :menu-title "Font Size")) ;  9-Aug-91 -wkf
  71. (defvar *font-style-menu* (make-instance 'font-menu :menu-title "Font Style")) ;  9-Aug-91 -wkf
  72.  
  73. ; In case this file is loaded more than once.
  74. (apply 'remove-menu-items *font-menu* (menu-items *font-menu*))
  75. (apply 'remove-menu-items *font-size-menu* (menu-items *font-size-menu*))
  76. (apply 'remove-menu-items *font-style-menu* (menu-items *font-style-menu*))
  77.  
  78. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79. ;;
  80. ;;  create a new class of menu-items for setting font attribute.
  81. ;;
  82. ;;  each menu-item has a title, and an attribute.  When the item is
  83. ;;  selected, it asks the top window to set-view-font to the attribute.
  84. ;;  In this way, there is only one action for the whole class.  (Each instance
  85. ;;  doesn't need its own action.  Each one just needs its own attribute).
  86. ;;
  87. ;;  The fact that the attribute is just like the name of the menu item
  88. ;;  is also convenient.
  89. ;;
  90.  
  91. (defclass font-menu-item (menu-item)
  92.   ((attribute :initarg :attribute
  93.               :reader attribute
  94.               :initform '("chicago" 12 :plain))))
  95.  
  96.  
  97. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98. ;;
  99. ;;  arrange to put check marks by the current values of the font attributes,
  100. ;;  by asking the view what the font is and seeing if this attribute is present
  101. ;;  in addition, if this is a size attribute, see if the font is real
  102. ;;
  103.  
  104. (defmethod menu-item-update ((item font-menu-item))
  105.   ;; !!! Get selection font from menu which calculates it just once per update. 9-Aug-91 -wkf
  106.   (let* ((owner          (menu-item-owner item))
  107.          (selection-font (selection-font owner))
  108.          (attribute      (attribute item))
  109.          (ff             (car selection-font))
  110.          (ms             (cdr selection-font))
  111.          (fontp          (integerp ff)))
  112.     (set-menu-item-check-mark 
  113.      item
  114.      (and fontp
  115.           (cond ((stringp attribute)
  116.                  (let ((aff (font-codes attribute)))
  117.                    (eql (point-v aff) (point-v ff))))
  118.                 ((integerp attribute)
  119.                  (eql attribute (point-h ms)))
  120.                 (t (let* ((cell (assq attribute *style-alist*))
  121.                           (value (cdr cell))
  122.                           (face-code (lsh (point-h ff) -8)))
  123.                      (and value
  124.                           (if (eql 0 value)
  125.                             (eql 0 face-code)
  126.                             (not (eql 0 (logand face-code value))))))))))
  127.     (when (integerp attribute)          ; if it's a size attribute
  128.         (set-menu-item-style 
  129.          item
  130.          (if (and fontp (#_RealFont (point-v ff) (point-h ms)))
  131.            :outline
  132.            :plain)))))
  133.  
  134. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  135. ;;
  136. ;;  the menu-item-action asks the front window to set its view-font
  137. ;;  to the menu-item's attribute.
  138. ;;  FRED-MIXIN instances are handled specially so that if the
  139. ;;  font of the entire screen is changed, the insertion font
  140. ;;  will track it (Mike Engber's idea).
  141. ;;
  142.  
  143. (defmethod menu-item-action ((item font-menu-item))
  144.   (let ((w (front-window)))
  145.     (when w
  146.       (smart-set-view-font (or (current-key-handler w) w) (attribute item)))))
  147.  
  148. (defmethod smart-set-view-font (self font-spec)
  149.   (set-view-font self font-spec))
  150.  
  151. (defmethod smart-set-view-font ((self fred-mixin) font-spec)
  152.   (let ((all-selected? nil)
  153.         (buf (fred-buffer self)))
  154.     (multiple-value-bind (start end) (selection-range self)
  155.       (if (eql start end)
  156.         (buffer-set-font-spec buf font-spec)
  157.         (progn
  158.           (buffer-set-font-spec buf font-spec start end)
  159.           (when (setq all-selected?
  160.                       (and (zerop start) (= end (buffer-size buf))))
  161.             (buffer-set-font-spec buf font-spec)))))
  162.     (buffer-remove-unused-fonts (fred-buffer self))
  163.     (if all-selected?
  164.       (fred-update self)
  165.       (window-show-cursor self))))
  166.  
  167.  
  168. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  169. ;;
  170. ;;  here we set up the font menu.  We make an item for each font listed
  171. ;;  in the global variable *font-list*.  In this case, the menu-item name
  172. ;;  and the attribute are exactly the same (a string giving the name of a
  173. ;;  font).
  174. ;;
  175. ;;  We process the *font-list* to remove fonts that begin with a "%",
  176. ;;  because these aren't meant to be displayed in font menus.
  177. ;;
  178.  
  179. (defun add-font-menus ()
  180.   (apply #'remove-menu-items *font-menu* (menu-items *font-menu*))
  181.   (dolist (font-name (remove #\% *font-list*
  182.                              :key #'(lambda (string)
  183.                                       (elt string 0))))
  184.     (add-menu-items *font-menu* (make-instance 'font-menu-item
  185.                                   :menu-item-title font-name
  186.                                   :attribute font-name))))
  187.  
  188. (pushnew 'add-font-menus *lisp-startup-functions*)
  189. (add-font-menus)
  190.  
  191. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  192. ;;
  193. ;;  here we set up the font size menu.  Each menu-item has a number
  194. ;;  for its attribute.  To get the name of the menu-item, we just print
  195. ;;  the number into a string using the function FORMAT.
  196. ;;
  197.  
  198.  
  199. (dolist (font-size '(9 10 12 14 18 24))
  200.   (add-menu-items *font-size-menu*
  201.                   (make-instance 'font-menu-item
  202.                                  :menu-item-title (format nil "~d" font-size)
  203.                                  :attribute font-size)))
  204.  
  205.  
  206. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  207. ;;
  208. ;;  here we set up the font style menu.  In this case it's easiest to just
  209. ;;  give the attribute explicitly.
  210. ;;
  211. ;;  Once the menu-items are set up, we ask them to change their font style,
  212. ;;  so that they are displayed in the style they represent.
  213. ;;
  214.  
  215.  
  216. (add-menu-items
  217.  *font-style-menu*
  218.  (make-instance 'font-menu-item :menu-item-title "Plain" :attribute :plain)
  219.  (make-instance 'font-menu-item :menu-item-title "Bold" :attribute :bold)
  220.  (make-instance 'font-menu-item :menu-item-title "Italic" :attribute :italic)
  221.  (make-instance 'font-menu-item :menu-item-title "Underline" :attribute :underline)
  222.  (make-instance 'font-menu-item :menu-item-title "Outline" :attribute :outline)
  223.  (make-instance 'font-menu-item :menu-item-title "Shadow" :attribute :shadow)
  224.  (make-instance 'font-menu-item :menu-item-title "Condense" :attribute :condense)
  225.  (make-instance 'font-menu-item :menu-item-title "Extend" :attribute :extend))
  226. (dolist (menu-item (menu-items *font-style-menu*))
  227.   (set-menu-item-style menu-item (attribute menu-item)))
  228.  
  229.  
  230. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  231. ;;
  232. ;;  now that we have all the menus, we just add them to the *edit-menu*
  233. ;;  (preceded by a blank-line menu-item).
  234. ;;
  235.  
  236. (unless (find-menu-item *edit-menu* (menu-item-title *font-menu*))
  237.   (add-menu-items *edit-menu*
  238.                   (make-instance 'menu-item :menu-item-title "-")   ;a blank line
  239.                   *font-menu* *font-size-menu* *font-style-menu*))
  240.  
  241.  
  242.  
  243.